;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: ("CONDITIONS" :USE "LISP" :SHADOW ("BREAK" "ERROR" "CERROR" "WARN" "CHECK-TYPE" "ASSERT" "ETYPECASE" "CTYPECASE" "ECASE" "CCASE")); Base: 10 -*-
;;;
;;; CONDITIONS: A more-or-less portable condition system for Common Lisp

(IN-PACKAGE "CONDITIONS" :USE '("LISP"))
(SHADOW '(BREAK ERROR CERROR WARN CHECK-TYPE ASSERT ETYPECASE CTYPECASE ECASE CCASE))
(EXPORT '(BREAK ERROR CERROR WARN CHECK-TYPE ASSERT ETYPECASE CTYPECASE ECASE CCASE
	  DEBUG ABORT PROCEED USE-VALUE STORE-VALUE WARNING SERIOUS-CONDITION
	  SIMPLE-CONDITION SIMPLE-WARNING SIMPLE-ERROR FORMAT-STRING FORMAT-ARGUMENTS
	  STORAGE-CONDITION STACK-OVERFLOW STORAGE-EXHAUSTED CONTROL-ERROR ILLEGAL-THROW
	  ILLEGAL-GO STREAM-ERROR READ-ERROR END-OF-FILE CELL-ERROR UNBOUND-VARIABLE
	  UNDEFINED-FUNCTION ARITHMETIC-ERROR DIVISION-BY-ZERO FLOATING-POINT-OVERFLOW
	  FLOATING-POINT-UNDERFLOW)) ;Actually, there are probably symbols missing here.

;;; Notes:
;;;
;;;  The processing of ERRORs should be structured so that the default handler for
;;;  ERROR does a DEBUG also. The net result will be that (ERROR error-condition)
;;;  has two calls to DEBUG in its path. This is necessary so that (SIGNAL error-condition)
;;;  and (ERROR non-error-condition) will work. Personally, I don't like the idea of
;;;  error conditions, but people seem to think they're necessary, so...

(EVAL-WHEN (EVAL COMPILE LOAD)

(DEFVAR *THIS-PACKAGE* (FIND-PACKAGE "CONDITIONS"))

);NEHW-LAVE


;;; TRUE isn't directly part of this proposal, but should probably go into the CL 
;;; spec anyway because it makes use of this facility much easier.

(DEFUN TRUE (&REST ARGUMENTS)
  ARGUMENTS ;ignored
  T)

(DEFUN FALSE (&REST ARGUMENTS)
  ARGUMENTS ;ignored
  NIL)

(DEFUN READ-TYPED-OBJECT (TYPE &OPTIONAL PROMPT)
  (FLET ((TRY () (FORMAT T "}&}A? " (OR PROMPT TYPE)) (READ)))
    (DO ((ANS (TRY) (TRY)))
        ((TYPEP ANS TYPE) ANS)
      (FORMAT T "}&Wrong type of response -- wanted }S}%" TYPE))))



(DEFVAR *MAKNUM-TABLE* (MAKE-HASH-TABLE))
(DEFVAR *MAKNUM-COUNT* -1)

(DEFUN MAKNUM (OBJ)
  (OR (GETHASH OBJ *MAKNUM-TABLE*)
      (SETF (GETHASH OBJ *MAKNUM-TABLE*) (INCF *MAKNUM-COUNT*))))

(DEFUN CONDITION-PRINT (CONDITION STREAM DEPTH)
  DEPTH ;ignored
  (COND (*PRINT-ESCAPE*
         (FORMAT STREAM "#<}S.}D>" (TYPE-OF CONDITION) (MAKNUM CONDITION)))
        (T
         (CONDITION-REPORT CONDITION STREAM))))

(DEFUN PROCEED-CASE-PRINT (PROCEED-CASE STREAM DEPTH)
  DEPTH ;ignored
  (COND (*PRINT-ESCAPE*
         (FORMAT STREAM "#<}S.}D>" (TYPE-OF PROCEED-CASE) (MAKNUM PROCEED-CASE)))
        (T
         (PROCEED-CASE-REPORT PROCEED-CASE STREAM))))



(DEFSTRUCT (CONDITION :CONC-NAME
                      (:CONSTRUCTOR |Constructor for CONDITION|)
                      (:PREDICATE NIL)
                      (:PRINT-FUNCTION CONDITION-PRINT))
  (-DUMMY-SLOT- NIL))

(EVAL-WHEN (EVAL COMPILE LOAD)

(DEFMACRO PARENT-TYPE     (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'PARENT-TYPE))
(DEFMACRO SLOTS           (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'SLOTS))
(DEFMACRO CONC-NAME       (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'CONC-NAME))
(DEFMACRO HANDLE-FUNCTION (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'HANDLE-FUNCTION))
(DEFMACRO REPORT-FUNCTION (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'REPORT-FUNCTION))
(DEFMACRO MAKE-FUNCTION   (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'MAKE-FUNCTION))

);NEHW-LAVE

(DEFMACRO NAMED-PROCEED-CASE-PRESCAN-FUNCTION (NAME)
  `(GET ,NAME 'NAMED-PROCEED-CASE-PRESCAN-FUNCTION))
(DEFMACRO NAMED-PROCEED-CASE-REPORT-FUNCTION (NAME)
  `(GET ,NAME 'NAMED-PROCEED-CASE-REPORT-FUNCTION))

(SETF (MAKE-FUNCTION   'CONDITION) '|Constructor for CONDITION|)
(SETF (HANDLE-FUNCTION 'CONDITION) #'FALSE)


(EVAL-WHEN (EVAL COMPILE LOAD) ;Some utilities that are used at macro expansion time

(DEFUN PARSE-KEYWORD-PAIRS (LIST KEYS)
  (DO ((L LIST (CDDR L))
       (K '() (LIST* (CADR L) (CAR L) K)))
      ((OR (NULL L) (NOT (MEMBER (CAR L) KEYS)))
       (VALUES (NREVERSE K) L))))

(DEFMACRO WITH-KEYWORD-PAIRS ((NAMES EXPRESSION &OPTIONAL KEYWORDS-VAR) &BODY FORMS)
  (LET ((TEMP (MEMBER '&REST NAMES)))
    (UNLESS (= (LENGTH TEMP) 2) (ERROR "&REST keyword is }:[missing};misplaced}]." TEMP))
    (LET ((KEY-VARS (LDIFF NAMES TEMP))
          (KEY-VAR (OR KEYWORDS-VAR (GENSYM)))
          (REST-VAR (CADR TEMP)))
      (LET ((KEYWORDS (MAPCAR #'(LAMBDA(X) (INTERN (STRING X) "KEYWORD")) KEY-VARS)))
        `(MULTIPLE-VALUE-BIND (,KEY-VAR ,REST-VAR)
             (PARSE-KEYWORD-PAIRS ,EXPRESSION ',KEYWORDS)
           (LET ,(MAPCAR #'(LAMBDA (VAR KEYWORD) `(,VAR (GETF ,KEY-VAR ,KEYWORD)))
                                 KEY-VARS KEYWORDS)
             ,@FORMS))))))

(DEFMACRO RESOLVE-FUNCTION (FUNCTION EXPRESSION RESOLVER)
  `(COND ((AND ,FUNCTION ,EXPRESSION)
          (CERROR "Use only the :}A information."
                  "Only one of :}A and :}A is allowed."
                  ',FUNCTION ',EXPRESSION))
         (,EXPRESSION
          (SETQ ,FUNCTION ,RESOLVER))))
         
(DEFUN PARSE-NEW-AND-USED-SLOTS (SLOTS PARENT-TYPE)
  (LET ((NEW '()) (USED '()))
    (DOLIST (SLOT SLOTS)
      (IF (SLOT-USED-P (CAR SLOT) PARENT-TYPE)
          (PUSH SLOT USED)
          (PUSH SLOT NEW)))
    (VALUES NEW USED)))

(DEFUN SLOT-USED-P (SLOT-NAME TYPE)
  (COND ((EQ TYPE 'CONDITION) NIL)
        ((NOT TYPE) (ERROR "The type }S does not inherit from CONDITION." TYPE))
        ((ASSOC SLOT-NAME (SLOTS TYPE)))
        (T
         (SLOT-USED-P SLOT-NAME (PARENT-TYPE TYPE)))))

(DEFUN MAKE-SLOT-ENCAPSULATION (FORM FOR-TYPE)
  (LET ((SLOT-BINDINGS '()))
    (DO ((TYPE FOR-TYPE (PARENT-TYPE TYPE)))
        ((NOT TYPE)
         (IF (NOT SLOT-BINDINGS)
             FORM 
             `(LET ,(REVERSE SLOT-BINDINGS)
                ,@(MAPCAR #'CAR SLOT-BINDINGS) ;ignorable
                ,FORM)))
      (DOLIST (SLOT (SLOTS TYPE))
        (LET ((SLOT-NAME (CAR SLOT)))
          (UNLESS (ASSOC SLOT-NAME SLOT-BINDINGS)
            (PUSH `(,SLOT-NAME (,(IF (NOT (CONC-NAME TYPE))
                                     SLOT-NAME
                                     (INTERN (FORMAT NIL "}A}A" (CONC-NAME TYPE) SLOT-NAME)
                                             (SYMBOL-PACKAGE (CONC-NAME TYPE))))
                                CONDITION))
                  SLOT-BINDINGS)))))))

);NEHW-LAVE



(DEFMACRO DEFINE-CONDITION (NAME PARENT-TYPE &REST KEYWORD-PAIRS-AND-SLOTS)
  (LET ((CONSTRUCTOR (LET ((*PACKAGE* *THIS-PACKAGE*))
                       (INTERN (FORMAT NIL "Constructor for }S" NAME)))))
    (WITH-KEYWORD-PAIRS ((CONC-NAME REPORT-FUNCTION REPORT HANDLE HANDLE-FUNCTION &REST SLOTS)
                         KEYWORD-PAIRS-AND-SLOTS
                         KEYWORDS)
      (SETQ SLOTS (MAPCAR #'(LAMBDA (SLOT) (IF (ATOM SLOT) (LIST SLOT) SLOT)) SLOTS))
      (MULTIPLE-VALUE-BIND (NEW-SLOTS USED-SLOTS)
          (PARSE-NEW-AND-USED-SLOTS SLOTS PARENT-TYPE)
        (LET* ((CONC-NAME-P (GET-PROPERTIES KEYWORDS '(:CONC-NAME)))
               (RESOLVED-CONC-NAME (IF CONC-NAME-P
                                       CONC-NAME
                                       (INTERN (FORMAT NIL "}A-" NAME)
                                               (SYMBOL-PACKAGE NAME)))))
          ;; The following three forms are compile-time side-effects. For now, they affect
          ;; the global environment, but with modified abstractions for PARENT-TYPE, SLOTS, 
          ;; and CONC-NAME, the compiler could easily make them local.
          (SETF (PARENT-TYPE NAME) PARENT-TYPE)
          (SETF (SLOTS NAME) SLOTS)
          (SETF (CONC-NAME NAME) RESOLVED-CONC-NAME)
	  ;; Now resolve some arguments
	  (RESOLVE-FUNCTION REPORT-FUNCTION REPORT
			    (IF (STRINGP REPORT)
				`(LAMBDA (CONDITION STREAM)
				   (DECLARE (IGNORE CONDITION))
				   (WRITE-STRING ,REPORT STREAM))
				`(LAMBDA (CONDITION *STANDARD-OUTPUT*)
				   CONDITION	;ignorable
				   ,(MAKE-SLOT-ENCAPSULATION REPORT NAME))))
	  (RESOLVE-FUNCTION HANDLE-FUNCTION HANDLE
			    `(LAMBDA (CONDITION)
			       ,(MAKE-SLOT-ENCAPSULATION HANDLE NAME)))
          ;; Finally, the expansion ...
          `(PROGN (DEFSTRUCT (,NAME
                              (:CONSTRUCTOR ,CONSTRUCTOR)
                              (:PREDICATE NIL)
                              (:PRINT-FUNCTION CONDITION-PRINT)
                              (:INCLUDE ,PARENT-TYPE ,@USED-SLOTS)
                              (:CONC-NAME ,RESOLVED-CONC-NAME))
                    ,@NEW-SLOTS)
                  (SETF (PARENT-TYPE ',NAME) ',PARENT-TYPE)
                  (SETF (SLOTS ',NAME) ',SLOTS)
                  (SETF (CONC-NAME ',NAME) ',RESOLVED-CONC-NAME)
                  (SETF (HANDLE-FUNCTION ',NAME) ,(IF HANDLE-FUNCTION `#',HANDLE-FUNCTION))
                  (SETF (REPORT-FUNCTION ',NAME) ,(IF REPORT-FUNCTION `#',REPORT-FUNCTION))
                  (SETF (MAKE-FUNCTION ',NAME) ',CONSTRUCTOR)
                  ',NAME))))))



(DEFINE-CONDITION WARNING CONDITION)

(DEFINE-CONDITION SERIOUS-CONDITION CONDITION
  :HANDLE (DEBUG CONDITION))

(DEFINE-CONDITION ERROR SERIOUS-CONDITION)

(DEFINE-CONDITION SIMPLE-CONDITION CONDITION
  :REPORT (APPLY #'FORMAT T FORMAT-STRING FORMAT-ARGUMENTS)
  FORMAT-STRING
  FORMAT-ARGUMENTS)

(DEFINE-CONDITION SIMPLE-WARNING WARNING
  :REPORT (APPLY #'FORMAT T FORMAT-STRING FORMAT-ARGUMENTS)
  FORMAT-STRING
  FORMAT-ARGUMENTS)

(DEFINE-CONDITION SIMPLE-ERROR ERROR
  :REPORT (APPLY #'FORMAT T FORMAT-STRING FORMAT-ARGUMENTS)
  FORMAT-STRING
  FORMAT-ARGUMENTS)

(DEFINE-CONDITION STORAGE-CONDITION SERIOUS-CONDITION)

(DEFINE-CONDITION STACK-OVERFLOW    STORAGE-CONDITION)
(DEFINE-CONDITION STORAGE-EXHAUSTED STORAGE-CONDITION)

(DEFINE-CONDITION CONTROL-ERROR ERROR)

(DEFINE-CONDITION ILLEGAL-THROW CONTROL-ERROR
  TAG)

(DEFINE-CONDITION ILLEGAL-GO CONTROL-ERROR
  TAG)

(DEFINE-CONDITION STREAM-ERROR ERROR
  STREAM)

(DEFINE-CONDITION READ-ERROR STREAM-ERROR)

(DEFINE-CONDITION END-OF-FILE READ-ERROR)

(DEFINE-CONDITION CELL-ERROR ERROR
  NAME)

(DEFINE-CONDITION UNBOUND-VARIABLE CELL-ERROR
  :REPORT (FORMAT T "The variable }S is unbound." NAME))
  
(DEFINE-CONDITION UNDEFINED-FUNCTION CELL-ERROR
  :REPORT (FORMAT T "The function }S is undefined." NAME))

(DEFINE-CONDITION ARITHMETIC-ERROR ERROR
  OPERATION
  OPERANDS)

(DEFINE-CONDITION DIVISION-BY-ZERO         ARITHMETIC-ERROR)
(DEFINE-CONDITION FLOATING-POINT-OVERFLOW  ARITHMETIC-ERROR)
(DEFINE-CONDITION FLOATING-POINT-UNDERFLOW ARITHMETIC-ERROR)



(DEFUN MAKE-CONDITION (TYPE &REST SLOT-INITIALIZATIONS)
  (LET ((FN (MAKE-FUNCTION TYPE)))
    (COND ((NOT FN) (ERROR "Not a condition type: }S" TYPE))
          (T (APPLY FN SLOT-INITIALIZATIONS)))))

(DEFUN CONDITION-REPORT (CONDITION STREAM)
  (DO ((TYPE (TYPE-OF CONDITION) (PARENT-TYPE TYPE)))
      ((NOT TYPE) (FORMAT STREAM "The condition }A occurred."))
    (LET ((REPORTER (REPORT-FUNCTION TYPE)))
      (WHEN REPORTER
        (FUNCALL REPORTER CONDITION STREAM)
        (RETURN NIL)))))



(DEFVAR *BOUND-HANDLERS* NIL)

(DEFMACRO CONDITION-BIND (BINDINGS &BODY FORMS)
  (UNLESS (EVERY #'(LAMBDA (X) (AND (LISTP X) (= (LENGTH X) 2))) BINDINGS)
    (ERROR "Ill-formed condition bindings."))
  `(LET ((*BOUND-HANDLERS* (LIST* ,@(MAPCAR #'(LAMBDA (X) `(CONS ',(CAR X) ,(CADR X)))
                                            BINDINGS)
                                  *BOUND-HANDLERS*)))
     ,@FORMS))

(DEFUN SIGNAL (DATUM &REST ARGUMENTS)
  (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-CONDITION 'SIGNAL))
        (*BOUND-HANDLERS* *BOUND-HANDLERS*))
    (LOOP (IF (NOT *BOUND-HANDLERS*) (RETURN))
          (LET ((HANDLER (POP *BOUND-HANDLERS*)))
            (WHEN (IF (ATOM (CAR HANDLER))
                      (TYPEP CONDITION (CAR HANDLER))
                      (SOME #'(LAMBDA (TYPE) (TYPEP CONDITION TYPE)) (CAR HANDLER)))
              (FUNCALL (CDR HANDLER) CONDITION))))
    (DO ((TYPE (TYPE-OF CONDITION) (PARENT-TYPE TYPE)))
        ((NOT TYPE))
      (LET ((FN (HANDLE-FUNCTION TYPE)))
        (IF FN (FUNCALL FN CONDITION))))
    CONDITION))

(DEFVAR *PROCEED-CASES* '())

(DEFSTRUCT (PROCEED-CASE (:PRINT-FUNCTION PROCEED-CASE-PRINT))
  (NAME NIL)
  TAG
  FUNCTION
  REPORT-FUNCTION)

(DEFUN PROCEED-CASE-REPORT (PROCEED-CASE STREAM)
  (FUNCALL (OR (PROCEED-CASE-REPORT-FUNCTION PROCEED-CASE)
               (LET ((NAME (PROCEED-CASE-NAME PROCEED-CASE)))
                 (OR (NAMED-PROCEED-CASE-REPORT-FUNCTION NAME)
                     #'(LAMBDA (STREAM)
                         (IF NAME
                             (FORMAT STREAM "}S" NAME)
                             (FORMAT STREAM "}S" PROCEED-CASE))))))
           STREAM))

(DEFUN COMPUTE-PROCEED-CASES () *PROCEED-CASES*)



(DEFMACRO PROCEED-CASE (FORM &REST CLAUSES)
  (OR (DO ((C CLAUSES (CDR C)))
          ((NOT C) NIL)
        (IF (AND (CAAR C) ;a named entry
                 (ASSOC (CAAR C) (CDR C)))
            (RETURN `(PROCEED-CASE (PROCEED-CASE ,FORM ,(LDIFF CLAUSES C)) ,C))))
      (LET ((OUTER-TAG (GENSYM))
            (INNER-TAG (GENSYM))
            (VALUES-VAR   (GENSYM))
            (FUNCTION-VAR (GENSYM))
            (NAMES      '())
            (TAGS       '())
            (FUNCTIONS  '())
            (OPTIONS-LISTS    '()))
        (DO ((I 0 (1+ I))
             (C CLAUSES (CDR C)))
            ((NOT C)
             (SETQ NAMES (NREVERSE NAMES))
             (SETQ TAGS (NREVERSE TAGS))
             (SETQ FUNCTIONS (NREVERSE FUNCTIONS))
             (SETQ OPTIONS-LISTS (NREVERSE OPTIONS-LISTS)))
          (LET ((CLAUSE (CAR C)))
            (LET ((NAME (CAR  CLAUSE))
                  (BVL  (CADR CLAUSE)))
              (WITH-KEYWORD-PAIRS ((REPORT REPORT-FUNCTION &REST FORMS)
                                   (CDDR CLAUSE))
                (RESOLVE-FUNCTION REPORT-FUNCTION REPORT
                                  (IF (STRINGP REPORT)
                                      `(LAMBDA (STREAM) (WRITE-STRING ,REPORT STREAM))
                                      `(LAMBDA (*STANDARD-OUTPUT*) ,REPORT)))
                (PUSH I TAGS)
                (PUSH NAME NAMES)
                (PUSH `#'(LAMBDA ,BVL ,@FORMS) FUNCTIONS)
                (PUSH (LIST :REPORT-FUNCTION (IF REPORT-FUNCTION `#',REPORT-FUNCTION))
                      OPTIONS-LISTS)))))
        `(BLOCK ,OUTER-TAG
           (LET ((,VALUES-VAR
                  (MULTIPLE-VALUE-LIST
                    (BLOCK ,INNER-TAG
                      (RETURN-FROM ,OUTER-TAG
                        (FLET ((,FUNCTION-VAR (&REST ARGUMENTS)
                                (RETURN-FROM ,INNER-TAG (APPLY #'VALUES ARGUMENTS))))
                          (LET ((*PROCEED-CASES*
                                  (LIST* ,@(MAPCAR #'(LAMBDA (NAME TAG OPTIONS-LIST)
                                                       `(APPLY #'MAKE-PROCEED-CASE
                                                               :NAME     ',NAME
                                                               :TAG      ',TAG
                                                               :FUNCTION #',FUNCTION-VAR
                                                               (LIST ,@OPTIONS-LIST)))
                                                   NAMES TAGS OPTIONS-LISTS)
                                         *PROCEED-CASES*)))
                            ,FORM)))))))
             (CASE (CAR ,VALUES-VAR)
               ,@(MAPCAR #'(LAMBDA (TAG FUNCTION)
                             `(,TAG (APPLY ,FUNCTION (CDR ,VALUES-VAR))))
                         TAGS FUNCTIONS)))))))

(DEFUN FIND-PROCEED-CASE (NAME)
  (DOLIST (P *PROCEED-CASES*)
    (WHEN (EQ (PROCEED-CASE-NAME P) NAME)
      (RETURN P))))

(DEFUN INVOKE-PROCEED-CASE (PROCEED-CASE &REST VALUES)
  (LET ((REAL-PROCEED-CASE (IF (TYPEP PROCEED-CASE 'PROCEED-CASE)
                               PROCEED-CASE
                               (OR (FIND-PROCEED-CASE PROCEED-CASE)
                                   (ERROR "Proceed case }S is not active." PROCEED-CASE)))))
    (APPLY (PROCEED-CASE-FUNCTION REAL-PROCEED-CASE)
           (PROCEED-CASE-TAG REAL-PROCEED-CASE)
           (LET ((PRESCAN (NAMED-PROCEED-CASE-PRESCAN-FUNCTION
                            (PROCEED-CASE-NAME REAL-PROCEED-CASE))))
             (IF PRESCAN (APPLY PRESCAN VALUES) VALUES)))))



(DEFMACRO DEFINE-PROCEED-FUNCTION (NAME &REST KEYWORD-PAIRS-AND-VARIABLES)
  (WITH-KEYWORD-PAIRS ((REPORT REPORT-FUNCTION &REST VARIABLES)
                       KEYWORD-PAIRS-AND-VARIABLES)
    (RESOLVE-FUNCTION REPORT-FUNCTION REPORT
                      (IF (STRINGP REPORT)
                          `(LAMBDA (STREAM) (WRITE-STRING ,REPORT STREAM))
                          `(LAMBDA (*STANDARD-OUTPUT*)
                             ,REPORT)))
    (LET ((VAR (INTERN (FORMAT NIL "}D-OR-FEWER-ARGUMENTS" (LENGTH VARIABLES))
                       *THIS-PACKAGE*)))
      (REMOVE NIL
              `(PROGN (DEFUN ,NAME (&REST ,VAR)
			(IF (FIND-PROCEED-CASE ',NAME)
			    (APPLY #'INVOKE-PROCEED-CASE ',NAME ,VAR)))
                      (SETF (NAMED-PROCEED-CASE-PRESCAN-FUNCTION ',NAME)
                            #'(LAMBDA (&OPTIONAL ,@VARIABLES)
                                (LIST ,@(MAPCAR #'CAR VARIABLES))))
                      ,(IF REPORT-FUNCTION `(SETF (NAMED-PROCEED-CASE-REPORT-FUNCTION ',NAME)
                                                  #',REPORT-FUNCTION))
                      ',NAME)))))

(DEFINE-PROCEED-FUNCTION PROCEED
    :REPORT "Proceed with no special action."
  (CONDITION))

;;; COERCE-TO-CONDITION
;;;  Internal routine used in ERROR, CERROR, BREAK, and WARN for parsing the
;;;  hairy argument conventions into a single argument that's directly usable 
;;;  by all the other routines.

(DEFUN COERCE-TO-CONDITION (DATUM ARGUMENTS DEFAULT-TYPE FUNCTION-NAME
                            &OPTIONAL (TARGET-TYPE 'CONDITION))
  #+LISPM (SETQ ARGUMENTS (COPY-LIST ARGUMENTS))
  (COND ((TYPEP DATUM TARGET-TYPE) DATUM)
        ((SYMBOLP DATUM)                        ;roughly, (SUBTYPEP DATUM 'CONDITION)
         (APPLY #'MAKE-CONDITION DATUM ARGUMENTS))
        ((STRINGP DATUM)
         (MAKE-CONDITION DEFAULT-TYPE
                         :FORMAT-STRING DATUM
                         :FORMAT-ARGUMENTS ARGUMENTS))
        (T
         (ERROR "Bad argument to }S: }S" FUNCTION-NAME DATUM))))

(DEFUN ERROR (DATUM &REST ARGUMENTS)
  (DEBUG (SIGNAL (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-ERROR 'ERROR))))

(DEFUN CERROR (CONTINUE-STRING DATUM &REST ARGUMENTS)
  (PROCEED-CASE (APPLY #'ERROR DATUM ARGUMENTS)
    (PROCEED (CONDITION)
        :REPORT (APPLY #'FORMAT T CONTINUE-STRING ARGUMENTS)
      CONDITION)))

(DEFUN BREAK (&OPTIONAL (DATUM "Break") &REST ARGUMENTS)
  (PROCEED-CASE (APPLY #'DEBUG DATUM ARGUMENTS)
    (PROCEED (CONDITION)
        :REPORT "Return from BREAK."
      CONDITION)))

(DEFUN WARN (DATUM &REST ARGUMENTS)
  (PROCEED-CASE
      (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-WARNING 'WARN 'WARNING)))
        (SIGNAL CONDITION)
        (FORMAT T "}&Warning: }A}%" CONDITION)
        (IF *BREAK-ON-WARNINGS* (BREAK "Debug Warning")))
    (MUFFLE-WARNING (CONDITION)
      CONDITION)))



(DEFINE-PROCEED-FUNCTION ABORT
    :REPORT "Abort."
  (CONDITION))

(DEFMACRO CATCH-ABORT (PRINT-FORM &BODY FORMS)
  (UNLESS FORMS (ERROR "Wrong number of arguments to CATCH-ABORT."))
  `(PROCEED-CASE (PROGN ,@FORMS)
     (ABORT (CONDITION)
         :REPORT ,PRINT-FORM
       (VALUES NIL CONDITION))))

(DEFMACRO CONDITION-CASE (FORM &REST CASES)
  (LET ((OUTER-TAG (GENSYM))
        (INNER-TAG (GENSYM)))
    `(BLOCK ,OUTER-TAG
       (FUNCALL (BLOCK ,INNER-TAG
                  (CONDITION-BIND ,(MAPCAR #'(LAMBDA (CASE)
                                               (LET ((TYPE  (CAR  CASE))
                                                     (BVL   (CADR CASE))
                                                     (FORMS (CDDR CASE)))
                                                 (IF (NOT BVL) (SETQ BVL (LIST (GENSYM))))
                                                 `(,TYPE
                                                   #'(LAMBDA ,BVL ,(CAR BVL) ;ignorable
                                                       (RETURN-FROM ,INNER-TAG
                                                          (LAMBDA () ,@FORMS))))))
                                           CASES)
                                     (RETURN-FROM ,OUTER-TAG ,FORM)))))))

(DEFMACRO IGNORE-ERRORS (&REST FORMS)
  `(CONDITION-CASE (PROGN ,@FORMS)
     (ERROR () NIL)))



(DEFVAR *DEBUG-LEVEL* 0)
(DEFVAR *DEBUG-ABORT* NIL)
(DEFVAR *DEBUG-PROCEED* NIL)
(DEFVAR *DEBUG-CONDITION* NIL)
(DEFVAR *DEBUG-PROCEED-CASES* NIL)
(DEFVAR *NUMBER-OF-DEBUG-PROCEED-CASES* 0)
(DEFVAR *DEBUG-EVAL* 'EVAL)
(DEFVAR *DEBUG-PRINT* #'(LAMBDA (VALUES) (FORMAT T "}&}{}S}↑,}%}⎇" VALUES)))

(DEFMACRO DEBUG-COMMAND                (X) `(GET ,X 'DEBUG-COMMAND))
(DEFMACRO DEBUG-COMMAND-ARGUMENT-COUNT (X) `(GET ,X 'DEBUG-COMMAND-ARGUMENT-COUNT))

(DEFMACRO DEFINE-DEBUG-COMMAND (NAME BVL &REST BODY)
  `(PROGN (SETF (DEBUG-COMMAND ',NAME) #'(LAMBDA ,BVL ,@BODY))
          (SETF (DEBUG-COMMAND-ARGUMENT-COUNT ',NAME) ,(LENGTH BVL))
          ',NAME))

(DEFUN READ-DEBUG-COMMAND ()
  (FORMAT T "}&Debug }D> " *DEBUG-LEVEL*)
  (LET ((LINE (STRING-TRIM '(#\Space #\Tab) (READ-LINE)))
        (EOF  (LIST NIL))
        (CMD  NIL))
    (WHEN (NOT (EQUAL LINE ""))
      (LET ((TEST (WHEN (OR (ALPHA-CHAR-P (AREF LINE 0))
                            (DIGIT-CHAR-P (AREF LINE 0)))
                    (LET ((*PACKAGE* *THIS-PACKAGE*))
                      (READ-FROM-STRING LINE NIL NIL)))))
        (IF (OR (INTEGERP TEST)
                (AND (SYMBOLP TEST) (GET TEST 'DEBUG-COMMAND)))
            (SETQ CMD TEST))
        (WITH-INPUT-FROM-STRING (STREAM LINE)
          (IF CMD
              (READ STREAM)
              (SETQ CMD 'EVAL))
          (DO ((FORM (READ STREAM NIL EOF)
                     (READ STREAM NIL EOF))
               (L '() (CONS FORM L)))
              ((EQ FORM EOF) (CONS CMD (NREVERSE L)))))))))
                   
(DEFINE-DEBUG-COMMAND EVAL (FORM)
  (FUNCALL *DEBUG-PRINT* (MULTIPLE-VALUE-LIST (FUNCALL *DEBUG-EVAL* FORM))))

(DEFINE-DEBUG-COMMAND ABORT ()
  (INVOKE-PROCEED-CASE *DEBUG-ABORT* *DEBUG-CONDITION*))

(DEFINE-DEBUG-COMMAND PROCEED ()
  (INVOKE-PROCEED-CASE *DEBUG-PROCEED* *DEBUG-CONDITION*))

(DEFINE-DEBUG-COMMAND ERROR ()
  (FORMAT T "}&}A}%" *DEBUG-CONDITION*)
  (SHOW-PROCEED-CASES *DEBUG-PROCEED-CASES* *NUMBER-OF-DEBUG-PROCEED-CASES*))

(DEFINE-DEBUG-COMMAND HELP ()
  (FORMAT T "}&You are in a portable debugger.}
             }%Type a proceed case number, a debugger command, or a form to evaluate.}
             }%Commands are:}
             }% HELP      Show this text.}
             }% ABORT     Exit by ABORT.}
             }% PROCEED   Exit by PROCEED.}
             }% ERROR     Reprint error message and proceed cases.}%"))

(DEFUN SHOW-PROCEED-CASES (PROCEED-CASES &OPTIONAL (MAX (LENGTH PROCEED-CASES)))
  (WHEN PROCEED-CASES
    (DO ((W (CEILING (LOG MAX 10)))
         (P PROCEED-CASES (CDR P))
         (I 0 (1+ I)))
        ((OR (NOT P) (= I MAX)))
      (FORMAT T "}&}V,' D: }A}%" W I (CAR P)))))



(DEFUN DEBUG (&OPTIONAL (DATUM "Debug") &REST ARGUMENTS)
  (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-CONDITION 'BREAK)))
    (LET ((*DEBUG-LEVEL* (1+ *DEBUG-LEVEL*))
	  (*DEBUG-ABORT*   (FIND-PROCEED-CASE 'ABORT))
	  (*DEBUG-PROCEED* (FIND-PROCEED-CASE 'PROCEED))
	  (*DEBUG-CONDITION* CONDITION))
      (FORMAT T "}&}A}%" CONDITION)
      (LET* ((*DEBUG-PROCEED-CASES* (COMPUTE-PROCEED-CASES))
	     (*NUMBER-OF-DEBUG-PROCEED-CASES* (LENGTH *DEBUG-PROCEED-CASES*)))
	(SHOW-PROCEED-CASES *DEBUG-PROCEED-CASES* *NUMBER-OF-DEBUG-PROCEED-CASES*)
	(DO ((COMMAND (READ-DEBUG-COMMAND)
		      (READ-DEBUG-COMMAND)))
	    (NIL)
	  (LET ((CMD  (CAR COMMAND))
		(ARGS (CDR COMMAND))
		(LEVEL *DEBUG-LEVEL*))
	    (CATCH-ABORT (FORMAT T "Return to debug level }D." LEVEL)
	      (COND ((NOT CMD))
		    ((INTEGERP CMD)
		     (COND (ARGS
			    (FORMAT T "}&No arguments are allowed with a proceed case."))
			   ((AND (NOT (MINUSP CMD))
				 (< CMD *NUMBER-OF-DEBUG-PROCEED-CASES*))
			    (INVOKE-PROCEED-CASE (NTH CMD *DEBUG-PROCEED-CASES*)))
			   (T
			    (FORMAT T "}&No such proceed case."))))
		    ((NOT (= (LENGTH ARGS) (DEBUG-COMMAND-ARGUMENT-COUNT CMD)))
		     (FORMAT T "}&Too }:[few};many}] things to }A."
			     (> (LENGTH ARGS) (DEBUG-COMMAND-ARGUMENT-COUNT CMD)) CMD))
		    (T
		     (APPLY (DEBUG-COMMAND CMD) ARGS))))))))))


;;; Crude interface to existing error systems

(DEFINE-PROCEED-FUNCTION USE-VALUE
    :REPORT "Specify a value to use this time."
  (VALUE (EVAL (READ-TYPED-OBJECT 'T "Value"))))

(DEFINE-PROCEED-FUNCTION STORE-VALUE
    :REPORT "Specify a value to store permanently and use this time."
  (VALUE (EVAL (READ-TYPED-OBJECT 'T "Value"))))

#+Symbolics
(DEFUN SYMBOLICS-UNBOUND-VARIABLE-HANDLER (ZL-CONDITION &OPTIONAL (STATE 0))
  (CASE STATE
    ((0) (IF (ZL:SEND ZL-CONDITION :PROCEED-TYPE-P :STORE-NEW-VALUE)
             (PROCEED-CASE (SYMBOLICS-UNBOUND-VARIABLE-HANDLER ZL-CONDITION 1)
               (STORE-VALUE (VALUE)
                 (ZL:SEND ZL-CONDITION :PROCEED :STORE-NEW-VALUE VALUE)))
             (SYMBOLICS-UNBOUND-VARIABLE-HANDLER ZL-CONDITION 1)))
    ((1) (IF (ZL:SEND ZL-CONDITION :PROCEED-TYPE-P :NEW-VALUE)
             (PROCEED-CASE (SYMBOLICS-UNBOUND-VARIABLE-HANDLER ZL-CONDITION 2)
               (USE-VALUE (VALUE)
                 (ZL:SEND ZL-CONDITION :PROCEED :NEW-VALUE VALUE)))
             (SYMBOLICS-UNBOUND-VARIABLE-HANDLER ZL-CONDITION 2)))
    ((2) (IF (ZL:SEND ZL-CONDITION :PROCEED-TYPE-P :NO-ACTION)
             (PROCEED-CASE (SYMBOLICS-UNBOUND-VARIABLE-HANDLER ZL-CONDITION 3)
               (PROCEED (CL-CONDITION)
	         CL-CONDITION ;ignored
                 (ZL:SEND ZL-CONDITION :PROCEED :NO-ACTION)))
             (SYMBOLICS-UNBOUND-VARIABLE-HANDLER ZL-CONDITION 3)))
    (OTHERWISE 
      (ERROR 'UNBOUND-VARIABLE :NAME (ZL:SEND ZL-CONDITION :VARIABLE-NAME)))))

#+Symbolics
(DEFUN SYMBOLICS-UNDEFINED-FUNCTION-HANDLER (ZL-CONDITION &OPTIONAL (STATE 0))
  (CASE STATE
    ((0) (IF (ZL:SEND ZL-CONDITION :PROCEED-TYPE-P :STORE-NEW-VALUE)
             (PROCEED-CASE (SYMBOLICS-UNDEFINED-FUNCTION-HANDLER ZL-CONDITION 1)
               (STORE-VALUE (VALUE)
                 (ZL:SEND ZL-CONDITION :PROCEED :STORE-NEW-VALUE VALUE)))
             (SYMBOLICS-UNDEFINED-FUNCTION-HANDLER ZL-CONDITION 1)))

    ((1) (IF (ZL:SEND ZL-CONDITION :PROCEED-TYPE-P :NEW-VALUE)
             (PROCEED-CASE (SYMBOLICS-UNDEFINED-FUNCTION-HANDLER ZL-CONDITION 2)
               (USE-VALUE (VALUE)
                 (ZL:SEND ZL-CONDITION :PROCEED :NEW-VALUE VALUE)))
             (SYMBOLICS-UNDEFINED-FUNCTION-HANDLER ZL-CONDITION 2)))
    ((2) (IF (ZL:SEND ZL-CONDITION :PROCEED-TYPE-P :NO-ACTION)
             (PROCEED-CASE (SYMBOLICS-UNDEFINED-FUNCTION-HANDLER ZL-CONDITION 3)
               (PROCEED (CL-CONDITION)
	         CL-CONDITION ;ignored
                 (ZL:SEND ZL-CONDITION :PROCEED :NO-ACTION)))
             (SYMBOLICS-UNDEFINED-FUNCTION-HANDLER ZL-CONDITION 3)))
    (OTHERWISE 
      (ERROR 'UNDEFINED-FUNCTION :NAME (ZL:SEND ZL-CONDITION :FUNCTION-NAME)))))

#+Symbolics
(DEFUN ZETALISP-CONDITION-DISPATCH (C) 
  (ZL:CONDITION-BIND ((ZL:ERROR #'ZETALISP-CONDITION-DISPATCH))
    (TYPECASE C
      ((SYS:UNBOUND-VARIABLE)
       (SYMBOLICS-UNBOUND-VARIABLE-HANDLER C))
      ((SYS:UNDEFINED-FUNCTION)
       (SYMBOLICS-UNDEFINED-FUNCTION-HANDLER C))
      (OTHERWISE
        (ERROR "}A" C)))))

#+Symbolics
(DEFMACRO WITH-CONDITION-SYSTEM (&BODY FORMS)
  `(ZL:CONDITION-BIND ((ZL:ERROR #'ZETALISP-CONDITION-DISPATCH))
     (PROCEED-CASE (PROGN ,@FORMS)
       (ABORT (CONDITION)
           :REPORT "Do a Zetalisp abort."
         CONDITION ;ignored
         (ZL:SIGNAL 'ZL:SYS:ABORT)))))

#+VAX
(DEFMACRO WITH-CONDITION-SYSTEM (&BODY FORMS)
  `(LET ((SYSTEM:*UNIVERSAL-ERROR-HANDLER*
           #'(LAMBDA (FOO BAR MSG &REST ARGS)
               (COND ((EQUAL MSG "Symbol has no value: }S")
                      ;; Interpreter errors seem to be proceedable
                      (LET ((VAR (FIRST ARGS)))
                        (SYSTEM::RETURN-FORCED-VALUES
                          NIL
                          (LIST
                            (PROCEED-CASE (ERROR 'UNBOUND-VARIABLE :NAME VAR)
                              (PROCEED (CONDITION)
				CONDITION ;ignored
				(SYMBOL-VALUE VAR))
                              (USE-VALUE (VALUE) VALUE)
                              (STORE-VALUE (VALUE) 
                                (SETF (SYMBOL-VALUE VAR) VALUE)
                                VALUE))))))
                     ;; Interpreter errors seem to be proceedable
                     ((EQUAL MSG "Symbol has no function definition: }S")
                      (LET ((FN (FIRST ARGS)))
                        (SYSTEM::RETURN-FORCED-VALUES
                          NIL
                          (LIST
                            (PROCEED-CASE (ERROR 'UNDEFINED-FUNCTION :NAME FN)
                              (PROCEED (CONDITION)
				CONDITION ;ignored
				(SYMBOL-FUNCTION FN))
                              (USE-VALUE (VALUE) VALUE)
                              (STORE-VALUE (VALUE)
                                (SETF (SYMBOL-FUNCTION FN) VALUE)
                                VALUE))))))
                    ;I don't remember exactly what the error message from
                    ; compiled code is, but they're not proceedable. -kmp
                    ;((EQUAL MSG "Call to undefined function }S in compiled code.")
                    ; (LET ((FN (FIRST ARGS)))
                    ;   (ERROR 'UNDEFINED-FUNCTION :NAME FN)))
                     (T
                      (APPLY #'ERROR MSG ARGS))))))
     (PROCEED-CASE (PROGN ,@FORMS)
       (ABORT (CONDITION)
           :REPORT "Do a VAXLISP abort."
         CONDITION ;ignored
         (SYSTEM:THROW-TO-COMMAND-LEVEL :CURRENT)))))


;;;; A sample application

(DEFINE-PROCEED-FUNCTION MY-USE-VALUE
    :REPORT "Specify a value to use this time."
  (VALUE (MY-EVAL (READ-TYPED-OBJECT 'T "Value"))))

(DEFINE-PROCEED-FUNCTION MY-STORE-VALUE
    :REPORT "Specify a value to store and use this time."
  (VALUE (MY-EVAL (READ-TYPED-OBJECT 'T "Value"))))

(DEFUN MY-REPL ()
  (LET ((*DEBUG-EVAL* 'MY-EVAL)
	(*DEBUG-PRINT* 'MY-PRINT))
    (DO ((FORM (READ-TYPED-OBJECT 'T "Eval")
               (READ-TYPED-OBJECT 'T "Eval")))
        ((NOT FORM))
      (CATCH-ABORT "Return to MY-REPL toplevel."
	(MY-PRINT (MULTIPLE-VALUE-LIST (MY-EVAL FORM)))))))

(DEFUN MY-PRINT (VALUES)
  (FORMAT T "}{}&=> }S}⎇" VALUES))

(DEFUN MY-APPLY (FN &REST ARGS)
  (IF (FUNCTIONP FN)
      (APPLY #'APPLY FN ARGS)
      (PROCEED-CASE (ERROR "Invalid function: }S" FN)
        (MY-USE-VALUE (X)
            :REPORT "Use a different function."
          (APPLY #'MY-APPLY X ARGS)))))



(DEFUN MY-EVAL (X)
  (COND ((NUMBERP X) X)
        ((SYMBOLP X)
         (IF (BOUNDP X)
             (SYMBOL-VALUE X)
             (PROCEED-CASE (ERROR 'UNBOUND-VARIABLE :NAME X)
               (NIL ()
                   :REPORT (FORMAT T "Retry the SYMBOL-VALUE operation on }S." X)
                 (MY-EVAL X))
               (MY-USE-VALUE (VALUE)
                   :REPORT (FORMAT T "Specify another value of }S to use this time." X)
                 VALUE)
               (MY-STORE-VALUE (VALUE)
                   :REPORT (FORMAT T "Specify another value of }S to store and use." X)
                 (SETF (SYMBOL-VALUE X) VALUE)
                 VALUE))))
        ((ATOM X)
         (ERROR "Illegal form: }S" X))
        ((NOT (ATOM (CAR X)))
         (MY-APPLY (MY-EVAL (CAR X)) (MAPCAR #'MY-EVAL (CDR X))))
        ((EQ (CAR X) 'LAMBDA)
         (LAMBDA (&REST ARGS)
           (MY-EVAL `(LET ,(MAPCAR #'LIST (CADR X) ARGS) ,@(CDDR X)))))
        ((MEMBER (CAR X) '(QUOTE FUNCTION)) (CADR X))
        ((EQ (CAR X) 'SETQ) (SETF (SYMBOL-VALUE (CADR X)) (MY-EVAL (CADDR X))))
        ((EQ (CAR X) 'DEFUN) (SETF (SYMBOL-FUNCTION (CADR X))
                                   (MY-EVAL `(LAMBDA ,@(CDDR X)))))
        ((EQ (CAR X) 'IF) (IF (MY-EVAL (CADR X))
                              (MY-EVAL (CADDR X))
                              (MY-EVAL (CADDDR X))))
        ((EQ (CAR X) 'LET) (PROGV (MAPCAR #'CAR (CADR X))
                                  (MAPCAR #'MY-EVAL (MAPCAR #'CADR (CADR X)))
                             (DO ((L (CDDR X) (CDR L)))
                                 ((NOT (CDR L)) (MY-EVAL (CAR L)))
                               (MY-EVAL (CAR L)))))
        ((NOT (SYMBOLP (CAR X)))
         (ERROR "Illegal form: }S" X))
        ((FBOUNDP (CAR X))
         (MY-APPLY (CAR X) (MAPCAR #'MY-EVAL (CDR X))))
        (T
         (PROCEED-CASE (ERROR 'UNDEFINED-FUNCTION :NAME (CAR X))
           (NIL ()
               :REPORT (FORMAT T "Retry the SYMBOL-FUNCTION operation on }S." (CAR X))
             (MY-EVAL X))
           (MY-USE-VALUE (VALUE)
               :REPORT (FORMAT T "Specify a function to use instead of }S this time."
                               (CAR X))
             (MY-APPLY VALUE (MAPCAR #'MY-EVAL (CDR X))))
           (MY-STORE-VALUE (VALUE)
               :REPORT (FORMAT T "Specify a function to store permanently and use for }S."
                               (CAR X))
             (SETF (SYMBOL-FUNCTION (CAR X)) VALUE)
             (MY-EVAL X))))))
βββ